Syntax10.Scn.Fnt
Syntax10b.Scn.Fnt
Syntax10i.Scn.Fnt
MODULE OPL;
(* Code emitter for MC68020.
 Diplomarbeit Samuel Urech
 Date: 04.11.92   Current version: 23.2.93
 changes in red and blue by Ralf Degner 22.5.1995
 020 specific code: Trapcc and many more
 bugfix for Move(): "CLR.X aY" not supported by 68020, OJ 16.5.96
 IMPORT OPT, OPM, SYSTEM;
 CONST
  NewLabel* = 0;
  (* item modes *)
  dreg = 0; areg = 1; freg = 2; postinc = 3; predec = 4; regx = 5; abs = 7; imm = 8; immL = 9; pcx = 10; coc = 12; fcoc = 13;
  (* object modes *)
  Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7;
  SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13;
  (* module visibility of objects *)
  internal = 0; external = 1; externalR = 2;
  (* instruction formats *)
  noext = 0; briefext = 1; fullext = 2; wordDispl = 3; longDispl = 4; extern = 5;
  (* sizes *)
  byte = 0; word = 1; long = 2;
  CP =  0F200H; (* Coprocessor word *)
  DIVS = 81C0H; DIVU = 80C0H; MULS = 0C1C0H; MULU = 0C0C0H;
  (* Condition Codes *)
  CC = 4; CS = 5; EQ = 7; false = 1; GE = 12; GT = 14; HI = 2; LE = 15;
  LS = 3; LT = 13; MI = 11; NE = 6; PL = 10; true = 0; VC = 8; VS = 9;
  (* Floating Point Condition Codes *)
  FEQ = 1; FNE = 0EH; FGT = 12H; FNGT = 1DH; FGE = 13H; FNGE = 1CH; FLT = 14H; FNLT = 1BH; FLE = 15H;
  FNLE = 1AH; Ffalse = 0; Ftrue = 0FH;
  (* Floating Point Control Registers *)
  FPCR = 4; FPSR = 2; FPIAR = 1;
  (* structure forms *)
  Undef = 0; Byte = 1; Bool = 2; Char = 3; SInt = 4; Int = 5; LInt = 6;
  Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12;
  Pointer = 13; ProcTyp = 14; Comp = 15;
  (* composite structure forms *)
  Basic = 1; Array = 2; DynArr = 3; Record = 4;
  IntSet = { SInt .. LInt };
  RealSet = { Real, LReal };
  ByteSet = { SInt, Byte, Char, Bool };
  WordSet = { Int };
  LongSet = { LInt, Set, Pointer, ProcTyp };
  None = -1; (* no index or offset register *)
  (* Implementation restrictions *)
  CodeLength = 65535; (* code size in bytes *)
  ConstSize* = 10000; (* constant size *)
  MaxEntry* = 256; (* maximum number of entries *)
  MaxPtrs = 256; (* maximum number of global pointers, old 128 *)
  MaxComs = 60; (* maximum number of commands, old 40 *)
  MaxExts* = 7; (* maximum number of extensions of a record type *)
  (* Offsets in type descriptor *)
  BaseTypeOffs* = 40;
  PtrTabOffs = BaseTypeOffs + 4 * ( MaxExts + 1 );
  MethodOffs* = -4;
 TYPE Label* = LONGINT;
   Item* = RECORD
    mode* : INTEGER; (* dreg, areg, freg, postinc, predec, regx, abs, imm, immL, pcx, coc, fcoc *)
    typ* : OPT.Struct;
    reg* : INTEGER; (* D0 .. D7: 0 .. 7, A0 .. A7: 8 .. 15, FP0 .. FP7: 16 .. 23 *)
    bd* : LONGINT;
    inxReg* : INTEGER; (* None = -1, D0 .. D7: 0 .. 7 *)
    xsize* : INTEGER; (* word: 0; long: 1 *)
    scale* : INTEGER; (* 0, 1, 2, 3 for sizes 1, 2, 4, 8 bytes *)
    tJump*, fJump* : Label; (* for coc- and fcoc-items only *)
    offsReg* : INTEGER; (* for multidimensional dynamic arrays only *)
    nolen* : INTEGER; (* pointer to dynamic array: number of lengths; string: length; 0 otherwise *)
   END; (* Item *)
(* Items:
mode       |  bd          reg     inxReg     xsize     scale    tJump    fJump
------------------------------------------------------------------------------
dreg       |              reg                                                  (0 .. 7)
areg       |              reg                                                  (8 .. 15)
freg       |              reg                                                  (16 .. 23)
postinc    |              reg
predec     |              reg
regx       |  bd          reg     inxReg     xsize     scale
abs        |  mno/eno
imm, immL  |  val
pcx        |  bd                  inxReg     xsize     scale
coc        |  t/fcond                                           tJump    fJump
fcoc       |  t/fcond                                           tJump    fJump
 VAR code : ARRAY CodeLength OF CHAR; (* generated code *)
   constant : ARRAY ConstSize OF SYSTEM.BYTE; (* constants *)
   entry* : ARRAY MaxEntry OF LONGINT; (* displacements of the exported objects or type descriptor address *)
   pc* : LONGINT;
   link* : INTEGER; (* root of fixup chain *)
   entno* : INTEGER; (* number of exported objects *)
   conx : LONGINT; (* index to the constant array *)
   nofrec : INTEGER; (* number of type descriptors *)
   dsize* : LONGINT; (* size of the global variables *)
   level* : SHORTINT; (* nesting level *)
   usedRegs* : SET; (* used registers: data registers: 0..7, address registers: 8..15, floating point registers: 16..23 *)
   LastSubBegin, LastSubEnd, SubWert : LONGINT;
 PROCEDURE Init*( opt : SET );
 BEGIN (* Init *)
  pc := 0;
  entno := 1; (* for module entry *)
  conx := ConstSize;
  nofrec := 0;
  dsize := 0;
  level := 0;
  usedRegs := {};
  link := 0
 END Init;
 PROCEDURE BegStat*;
 (* Frees all registers. Should be called at the beginning of a statement. *)
 BEGIN (* BegStat *)
  usedRegs := { }
 END BegStat;
 PROCEDURE PutByte( x : LONGINT );
 (* Writes a byte to the code and increments the PC. *)
 BEGIN (* PutByte *)
  IF pc >= CodeLength THEN
   OPM.err( 210 )
  ELSE
   code[ pc ] := CHR( x );
   INC( pc )
  END; (* IF *)
 END PutByte;
 PROCEDURE PutWord( x : LONGINT );
 (* Writes a word to the code and increments the PC by 2. *)
 BEGIN
  PutByte( x DIV 100H );
  PutByte( x MOD 100H )
 END PutWord;
 PROCEDURE PutLongWord( x : LONGINT );
 (* Writes a longword to the code and increments the PC by 4. *)
 BEGIN
  PutWord( x DIV 10000H );
  PutWord( x MOD 10000H )
 END PutLongWord;
 PROCEDURE ConstWord*( pos : INTEGER; val : LONGINT );
 (* Puts the word val at position pos into the constant area. *)
 BEGIN (* ConstWord *)
  constant[ pos ] := CHR( val DIV 100H );
  constant[ pos + 1 ] := CHR( val )
 END ConstWord;
 PROCEDURE PatchWord( pos, val : LONGINT );
 (* Patches the value val at position pos in the code. *)
 BEGIN (* PatchWord *)
  code[ pos ] := CHR( val DIV 100H );
  code[ pos + 1 ] := CHR( val )
 END PatchWord;
 PROCEDURE SetEntry*( pos : INTEGER; val : LONGINT );
 (* Sets entry[ pos ] to the given value. *)
 BEGIN (* SetEntry *)
  entry[ pos ] := val
 END SetEntry;
 PROCEDURE DispSize( disp : LONGINT ) : INTEGER;
 (* Returns a code for the size of a displacement. This code is used in the extension word.
   0         --> 1
   16 Bit --> 2
   32 Bit --> 3 *)
 BEGIN (* DispSize *)
  IF disp = 0 THEN RETURN 1
  ELSIF ( disp >= MIN( INTEGER ) ) & ( disp <= MAX( INTEGER ) ) THEN RETURN 2
  ELSE RETURN 3
  END
 END DispSize;
 PROCEDURE Trapcc*( condition, trapnr : INTEGER );
 (* Writes the code for TRAPcc. *)
 BEGIN (* Trapcc *)
  PutWord( 50FAH + SYSTEM.LSH( condition, 8 ) );
  PutWord( trapnr )
 END Trapcc;
 PROCEDURE LengthCode( size : LONGINT ) : INTEGER;
 (* Returns the size code that is used in the instruction. *)
 BEGIN (* LengthCode *)
  CASE size OF
   1 : RETURN byte
   | 2 : RETURN word
   | 4 : RETURN long
  END; (* CASE *)
 END LengthCode;
 PROCEDURE FloatFormat( typ : OPT.Struct ) : INTEGER;
 (* Returns the code that is filled into the source specifier field of a floating point instruction. *)
 BEGIN (* FloatFormat *)
  IF typ.form IN ByteSet THEN RETURN 6
  ELSIF typ.form IN WordSet THEN RETURN 4
  ELSIF typ.form IN LongSet THEN RETURN 0
  ELSIF typ = OPT.realtyp THEN RETURN 1
  ELSIF typ = OPT.lrltyp THEN RETURN 5
  ELSE HALT( 96 )
  END; (* IF *)
 END FloatFormat;
 PROCEDURE Scale*( size : LONGINT ) : INTEGER;
 (* Returns the code for the scale factor of a size. *)
 BEGIN (* Scale *)
  CASE size OF
   1 : RETURN 0
   | 2 : RETURN 1
   | 4 : RETURN 2
   | 8 : RETURN 3
  END; (* CASE *)
 END Scale;
 PROCEDURE FindPtrs*( typ : OPT.Struct; adr : LONGINT; VAR ptrTab : ARRAY OF LONGINT; VAR nofptrs : INTEGER );
 (* Appends the pointer addresses to ptrTab that occur in the given type. nofptrs is incremented accordingly. *)
  VAR fld: OPT.Object;
    btyp : OPT.Struct;
    i, n, s : LONGINT;
 BEGIN (* FindPtrs *)
  IF typ.form = Pointer THEN
   IF nofptrs < LEN( ptrTab ) THEN
   	ptrTab[ nofptrs ] := adr
   ELSE
   	OPM.Mark(222, 0); nofptrs:=0
   END;
   INC( nofptrs )
  ELSIF typ.comp = Record THEN
   btyp := typ.BaseTyp;
   IF btyp # NIL THEN FindPtrs( btyp, adr, ptrTab, nofptrs ) END;
   fld := typ.link;
   WHILE ( fld # NIL ) & ( fld.mode = Fld ) DO
    IF fld.name # OPM.HdPtrName THEN
     FindPtrs( fld.typ, fld.adr + adr, ptrTab, nofptrs )
    ELSE
     IF nofptrs < LEN( ptrTab ) THEN
     	ptrTab[ nofptrs ] := fld.adr + adr
    ELSE
    	OPM.Mark(222, 0); nofptrs:=0
    END;
     INC( nofptrs )
    END; (* IF *)
    fld := fld.link
   END; (* IF *)
  ELSIF typ.comp = Array THEN
   btyp := typ.BaseTyp;
   n := typ.n;
   WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END;
   IF ( btyp.form = Pointer ) OR ( btyp.comp = Record ) THEN
    i := 0; s := btyp.size;
    WHILE i < n DO FindPtrs( btyp, i * s + adr, ptrTab, nofptrs ); INC( i ) END
   END; (* IF *)
  ELSIF typ.comp = DynArr THEN
   FindPtrs( typ.BaseTyp, 0, ptrTab, nofptrs )
  END; (* IF *)
 END FindPtrs;
 PROCEDURE MakeTypDesc( typ : OPT.Struct; offset : LONGINT; VAR typdesc : ARRAY OF CHAR; VAR pos : LONGINT );
 (* Generates a type descriptor. *)
  VAR
    i: INTEGER;
    j: LONGINT;
    nofptrs : INTEGER;
    baseTyp : OPT.Struct;
    tProcTab : ARRAY MaxEntry OF OPT.Object;
    ptrTab : ARRAY 1000 OF LONGINT;
  PROCEDURE FindTProcs( typ : OPT.Struct );
  (* Writes all methods of the given type into tProcTab. *)
   PROCEDURE trav( obj : OPT.Object );
   BEGIN
    IF obj # NIL THEN
     IF obj.mode = TProc THEN tProcTab[ obj.adr DIV 10000H ] := obj END;
     trav(obj.left);
     trav(obj.right)
    END
   END trav;
  BEGIN (* FindTProcs *)
   IF typ.BaseTyp # NIL THEN FindTProcs( typ.BaseTyp ) END;
   trav( typ.link )
  END FindTProcs;
  PROCEDURE SetByte( pos, val : INTEGER );
  (* Sets the byte at offset pos in the type descriptor to value val. *)
  BEGIN (* SetByte *)
   typdesc[ pos + offset ] := CHR( val )
  END SetByte;
  PROCEDURE SetWord( pos, val : INTEGER );
  (* Sets the word at offset pos in the type descriptor to value val. *)
  BEGIN (* SetWord *)
   typdesc[ pos + offset ] := CHR( val DIV 100H );
   typdesc[ pos + offset + 1 ] := CHR( val MOD 100H )
  END SetWord;
  PROCEDURE SetLong( pos : INTEGER; val : LONGINT );
  (* Sets the longword at offset pos in the type descriptor to value val. *)
  BEGIN (* SetLong *)
   SetWord( pos, SHORT( val DIV 10000H ) );
   SetWord( pos + 2, SHORT( val MOD 10000H ) )
  END SetLong;
  PROCEDURE Set24( pos : INTEGER; VAR name : ARRAY OF CHAR );
  (* Sets the next 24 Bytes at offset pos in the type descriptor to name. *)
   VAR i : INTEGER;
  BEGIN (* Set24 *)
   i := 0;
   WHILE ( i < 24 ) & ( i < LEN( name ) ) DO
    typdesc[ pos + offset + i ] := name[ i ];
    INC( i )
   END; (* WHILE *)
  END Set24;
 BEGIN (* MakeTypDesc *)
  FOR j := 0 TO LEN( typdesc ) - 1 DO typdesc[ j ] := 0X END;
  SetLong( 0, typ.size );
  SetWord( 4, typ.extlev );
  SetWord( 6, SHORT( typ.n ) );
  IF typ.strobj # NIL THEN
   Set24( 16, typ.strobj.name )
  END; (* IF *)
  SetByte( BaseTypeOffs + 4 * typ.extlev + 2, typ.mno );
  SetByte( BaseTypeOffs + 4 * typ.extlev + 3, entno );
  baseTyp := typ.BaseTyp;
  WHILE baseTyp # NIL DO
   SetByte( BaseTypeOffs + 4 * baseTyp.extlev + 2, baseTyp.mno );
   SetByte( BaseTypeOffs + 4 * baseTyp.extlev + 3, SHORT( baseTyp.tdadr ) );
   baseTyp := baseTyp.BaseTyp
  END; (* WHILE *)
  nofptrs := 0;
  FindPtrs( typ, 0, ptrTab, nofptrs );
  FOR i := 0 TO nofptrs - 1 DO SetLong( PtrTabOffs + 4 * i, ptrTab[ i ] ) END;
  SetLong( PtrTabOffs + 4 * nofptrs, -( PtrTabOffs + 4 * nofptrs ) );
  FindTProcs( typ );
  FOR i := 0 TO SHORT(typ.n) - 1 DO
   SetByte( MethodOffs - 4 * ( i + 1 ) + 2, -tProcTab[ i ].mnolev );
   SetByte( MethodOffs - 4 * ( i + 1 ) + 3, SHORT( tProcTab[ i ].adr MOD 100H ) )
  END; (* FOR *)
  pos := PtrTabOffs + 4 * nofptrs + 4
 END MakeTypDesc;
 PROCEDURE AllocBytes*( VAR s : ARRAY OF SYSTEM.BYTE; len : LONGINT; VAR adr : LONGINT );
 (* Allocates s of length len in the constant area with alignment on 8 bytes. adr returns the new address. *)
  VAR align : LONGINT;
 BEGIN (* AllocBytes *)
  align := ( -len ) MOD 8;
  WHILE ( align > 0 ) & ( conx > 0 ) DO
   DEC( conx );
   constant[ conx ] := 0X;
   DEC( align )
  END; (* WHILE *)
  WHILE ( len > 0 ) & ( conx > 0 ) DO
   DEC( conx );
   DEC( len );
   constant[ conx ] := s[ len ]
  END; (* WHILE *)
  adr := conx;
  IF len > 0 THEN
   OPM.err( 230 )
  END; (* IF *)
 END AllocBytes;
 PROCEDURE AllocTypDesc*( typ : OPT.Struct );
 (* Allocates a type descriptor in the constant area. *)
  VAR typdesc : ARRAY 1000 OF CHAR;
    adr, pos, neg : LONGINT;
 BEGIN (* AllocTypDesc *)
  IF ( typ.comp = Record ) & ( typ.tdadr = OPM.TDAdrUndef ) THEN
   neg := -MethodOffs + 4 * typ.n;
   INC( neg, ( -neg ) MOD 8 );
   MakeTypDesc( typ, neg, typdesc, pos );
   INC( pos, ( -pos ) MOD 8 ); (* alignment to 8 because of the Garbage Collector *)
   AllocBytes( typdesc, pos + neg, adr );
   SetEntry( entno, adr - ConstSize - dsize + neg );
   typ.tdadr := entno;
   INC( entno );
   IF typ.extlev > MaxExts THEN OPM.err( 233 )
   ELSE INC( nofrec )
   END; (* IF *)
  END; (* IF *)
 END AllocTypDesc;
 PROCEDURE AllocConst*( obj : OPT.Object; typ : OPT.Struct; VAR bytes : ARRAY OF SYSTEM.BYTE; len : LONGINT;
           VAR item : Item );
 (* Allocates a constant in the constant area if necessary and returns an item describing it. *)
  VAR adr : LONGINT;
 BEGIN (* AllocConst *)
  IF obj = NIL THEN (* no name constant *)
   AllocBytes( bytes, len, adr );
   item.mode := pcx;
   item.inxReg := None;
   item.bd := adr - ConstSize - dsize
  ELSIF obj.conval.intval = OPM.ConstNotAlloc THEN (* named constant not yet allocated *)
   AllocBytes( bytes, len, adr );
   item.mode := pcx;
   item.inxReg := None;
   item.bd := adr - ConstSize - dsize;
   obj.conval.intval := item.bd
  ELSE (* named allocated constant *)
   item.mode := pcx;
   item.inxReg := None;
   item.bd := obj.conval.intval
  END; (* IF *)
  item.typ := typ
 END AllocConst;
 PROCEDURE DefineLabel*( VAR label : Label );
 (* Defines a label and solves its fixup chain if necessary. *)
  VAR next : Label;
    disp : LONGINT;
 BEGIN (* DefineLabel *)
  IF label > 0 THEN HALT( 97 ) END;
  LastSubEnd:=0;
  label := -label;
  WHILE label # NewLabel DO (* solve fixup chain *)
   next := 2 * ( 100H * LONG( ORD( code[ label ] ) ) + LONG( ORD( code[ label + 1 ] ) ) );
   disp := pc - label;
   IF ( disp < MIN( INTEGER ) ) OR ( disp > MAX( INTEGER ) ) THEN
    OPM.err( 211 )
   END;
   PatchWord( label, disp );
   label := next
  END; (* WHILE *)
  label := pc
 END DefineLabel;
 PROCEDURE MergedLinks*( l0, l1 : Label ) : Label;
 (* Merges the fixup chains of the two labels. *)
  VAR cur, next : Label;
 BEGIN (* MergedLinks *)
  IF l0 < 0 THEN
   cur := -l0;
   LOOP
    next := 2 * ( 100H * LONG( ORD( code[ cur ] ) ) + LONG( ORD( code[ cur + 1 ] ) ) );
    IF next = NewLabel THEN EXIT END;
    cur := next
   END; (* LOOP *)
   PatchWord( cur, -l1 DIV 2 );
   RETURN l0
  ELSE RETURN l1
  END; (* IF *)
 END MergedLinks;
 PROCEDURE Jump*( condition : INTEGER; VAR label : Label );
 (* Generates code for a conditional branch to the given label. If the label is not yet defined, the fixup chain is appended. *)
  VAR disp : LONGINT;
 BEGIN (* Jump *)
  IF label > 0 THEN (* label defined*)
   disp := label - pc - 2;
   IF ( disp >= MIN( SHORTINT ) ) & ( disp < MAX( SHORTINT ) ) THEN
    IF disp < 0 THEN INC( disp, 256 ) END;
    PutWord( 6000H + SYSTEM.LSH( condition, 8 ) + disp )
   ELSIF ( disp >= MIN( INTEGER ) ) & ( disp < MAX( INTEGER ) ) THEN
    PutWord( 6000H + SYSTEM.LSH( condition, 8 ) );
    PutWord( disp )
   ELSE
    OPM.err( 211 )
   END; (* IF *)
  ELSE (* label undefined, append fixup chain *)
   PutWord( 6000H + SYSTEM.LSH( condition, 8 ) );
   PutWord( -label DIV 2 );
   label := -( pc - 2 )
  END; (* IF *)
 END Jump;
 PROCEDURE FJump*( condition : INTEGER; VAR label : Label );
 (* Generates code for a conditional branch to the given label. The condition is a floating point condition.
  If the label is not yet defined, the fixup chain is appended. *)
 (* something went wrong with backjumps => problems with REPEAT UNTIL FloadCond *)
  VAR disp : LONGINT;
 BEGIN (* FJump *)
  PutWord( CP + 80H + condition );
  IF label > 0 THEN (* label defined *)
   disp := label - pc - 2 + 2;
   IF DispSize( disp ) = 2 THEN
    PutWord( disp )
   ELSE
    OPM.err( 211 )
   END; (* IF *)
  ELSE (* label undefined, append fixup chain *)
   PutWord( -label DIV 2 );
   label := -( pc - 2 )
  END; (* IF *)
 END FJump;
 PROCEDURE Bsr*( VAR label : Label );
 (* Writes the code for a subroutine call to the given label. If the label is not yet defined, the fixup chain is appended. *)
  VAR disp : LONGINT;
 BEGIN (* Bsr *)
  IF label > 0 THEN (* label defined *)
   disp := label - pc - 2;
   IF ( disp >= MIN( SHORTINT ) ) & ( disp <= MAX( SHORTINT ) ) THEN
    IF disp < 0 THEN INC( disp, 256 ) END;
    PutWord( 6100H + disp )
   ELSIF DispSize( disp ) = 2 (* word *) THEN
    PutWord( 6100H );
    PutWord( disp )
   ELSE (* long *)
    PutWord( 61FFH );
    PutLongWord( disp )
   END; (* IF *)
  ELSE (* label undefined, append fixup chain *)
   PutWord( 6100H );
   PutWord( -label DIV 2 );
   label := -( pc - 2 )
  END; (* IF *)
 END Bsr;
 PROCEDURE Encode( VAR item : Item; VAR mode, reg, extWord, format : INTEGER; VAR bd : LONGINT; offset : INTEGER );
 (* Returns mode, register, extension word and format of an item.
  The following values have to be written to the code:
   format = noext: mode, reg
   format = briefext: mode, reg, extWord
   format = fullext: mode, reg, extWord, bd (if # 0)
   format = wordDispl, longDispl, extern: mode, reg, bd *)
 BEGIN (* Encode *)
  bd := item.bd;
  CASE item.mode OF
   dreg : mode := 0; reg := item.reg; format := noext
   | areg : mode := 1; reg := item.reg - 8; format := noext
   | freg : mode := 0; reg := 0; format := noext
   | postinc : mode := 3; reg := item.reg - 8; format := noext
   | predec : mode := 4; reg := item.reg - 8; format := noext
   | regx :
    IF item.inxReg = None THEN
     CASE DispSize( bd ) OF
      1 :
       mode := 2;
       format := noext
      | 2 :
       mode := 5;
       format := wordDispl
      | 3 :
       mode := 6;
       extWord := 170H;
       format := fullext
     END; (* CASE *)
    ELSE
     mode := 6;
     IF ( bd >= MIN( SHORTINT ) ) & ( bd <= MAX( SHORTINT ) ) THEN
      IF bd < 0 THEN INC( bd, 100H ) END;
      extWord := SYSTEM.LSH( item.inxReg, 12 ) + SYSTEM.LSH( item.xsize, 11 ) + SYSTEM.LSH( item.scale, 9 ) +
           SHORT( bd );
      format := briefext
     ELSE
      extWord := SYSTEM.LSH( item.inxReg, 12 ) + SYSTEM.LSH( item.xsize, 11 ) + SYSTEM.LSH( item.scale, 9 ) +
           SYSTEM.LSH( DispSize( bd ), 4 ) + 100H;
      format := fullext
     END; (* IF *)
    END; (* IF *)
    reg := item.reg - 8
   | abs :
    mode := 7;
    reg := 1;
    format := extern
   | imm :
    mode := 7;
    reg := 4;
    IF item.typ.size = 4 THEN
     format := longDispl
    ELSE
     format := wordDispl
    END; (* IF *)
   | immL :
    mode := 7;
    reg := 4;
    format := extern
   | pcx :
    DEC( bd, pc + offset );
    mode := 7;
    IF item.inxReg = None THEN
     IF DispSize( bd ) < 3 THEN
      reg := 2;
      format := wordDispl
     ELSE
      reg := 3;
      format := fullext;
      extWord := 170H
     END; (* IF *)
    ELSE
     reg := 3;
     IF ( bd >= MIN( SHORTINT ) ) & ( bd <= MAX( SHORTINT ) ) THEN
      IF bd < 0 THEN INC( bd, 100H ) END;
      extWord := SYSTEM.LSH( item.inxReg, 12 ) + SYSTEM.LSH( item.xsize, 11 ) +
           SYSTEM.LSH( item.scale, 9 ) + SHORT( bd );
      format := briefext
     ELSE
      extWord := SYSTEM.LSH( item.inxReg, 12 ) + SYSTEM.LSH( item.xsize, 11 ) +
           SYSTEM.LSH( item.scale, 9 ) + SYSTEM.LSH( DispSize( bd ), 4 ) + 100H;
      format := fullext
     END; (* IF *)
    END; (* IF *)
  END; (* CASE *)
 END Encode;
 PROCEDURE PutExtension( format, extWord : INTEGER; bd : LONGINT );
 (* Writes extensions to the code according to the given format. *)
  VAR val : LONGINT;
 BEGIN (* PutExtension *)
  CASE format OF
   noext : (* nothing *)
   | briefext : PutWord( extWord )
   | fullext :
    PutWord( extWord );
    CASE DispSize( bd ) OF
     1 : (* nothing *)
     | 2 : PutWord( bd )
     | 3 : PutLongWord( bd )
    END
   | wordDispl :
    PutWord( bd )
   | longDispl :
    PutLongWord( bd )
   | extern : (* this was an external reference; link chain has to be appended *)
    val := SYSTEM.LSH( LONG( link ), 16 ) + bd;
    link := SHORT( pc DIV 2 );
    PutLongWord( val )
  END; (* CASE *)
 END PutExtension;
 PROCEDURE GetReg*( ) : INTEGER;
 (* Returns the next free data register. *)
  VAR i : INTEGER;
 BEGIN (* GetReg *)
  i := 0;
  WHILE ( i < 8 ) & ( i IN usedRegs ) DO INC( i ) END;
  IF i = 8 THEN
   OPM.err( 215 )
  END;
  INCL( usedRegs, i );
  RETURN i
 END GetReg;
 PROCEDURE GetAdrReg*( ) : INTEGER;
 (* Returns the next free address register. A6 and A7 are not returned. *)
  VAR i,j : INTEGER;
 BEGIN (* GetAdrReg *)
  i:=8;
  WHILE ( i < 14 ) & ( i IN usedRegs ) DO INC( i ) END;
  IF i = 14 THEN
   OPM.err( 215 )
  END;
  INCL( usedRegs, i );
  RETURN i
 END GetAdrReg;
 PROCEDURE GetFReg*( ) : INTEGER;
 (* Returns the next free floating point register. FP7 is reserved for code procedures. *)
  VAR i : INTEGER;
 BEGIN (* GetFReg *)
  i := 16;
  WHILE ( i < 23 ) & ( i IN usedRegs ) DO INC( i ) END;
  IF i = 23 THEN
   OPM.err( 216 )
  END;
  INCL( usedRegs, i );
  RETURN i
 END GetFReg;
 PROCEDURE FreeReg*( VAR item : Item );
 (* Frees all registers that are used by the item. The item must be defined before and is undefined afterwards. *)
 BEGIN (* FreeReg *)
  IF item.mode IN { dreg, areg, freg, postinc, predec, regx } THEN
   EXCL( usedRegs, item.reg )
  END; (* IF *)
  IF ( item.inxReg # None ) & ( item.mode IN { regx, pcx } ) THEN
   EXCL( usedRegs, item.inxReg )
  END; (* IF *)
 END FreeReg;
 PROCEDURE Lea*( VAR source : Item; destReg : INTEGER );
 (* Writes the code for LEA. *)
  VAR mode, reg, extWord, format : INTEGER;
    bd : LONGINT;
 BEGIN (* Lea *)
  Encode( source, mode, reg, extWord, format, bd, 2 );
  PutWord( 41C0H + SYSTEM.LSH( destReg - 8, 9 ) + SYSTEM.LSH( mode, 3 ) + reg );
  PutExtension( format, extWord, bd )
 END Lea;
 PROCEDURE LoadAdr*( VAR item : Item );
 (* If the item is pc-relative, its address is loaded into an address register. *)
  VAR reg : INTEGER;
 BEGIN (* LoadAdr *)
  IF item.mode = pcx THEN
   reg := GetAdrReg( );
   Lea( item, reg );
   item.mode := regx;
   item.reg := reg;
   item.bd := 0;
   item.inxReg := None;
   item.offsReg := None
  END; (* IF *)
 END LoadAdr;
 PROCEDURE LoadExternal*( VAR item : Item );
 (* If the item is an external reference, its address is loaded into an address register and a regx item is returned. *)
  VAR reg : INTEGER;
 BEGIN (* LoadExternal *)
  IF item.mode = abs THEN
   reg := GetAdrReg( );
   Lea( item, reg );
   item.mode := regx;
   item.reg := reg;
   item.bd := 0;
   item.inxReg := None;
   item.offsReg := None
  END; (* IF *)
 END LoadExternal;
 PROCEDURE Format7*( opcode : LONGINT; VAR dest : Item );
 (* CLR, NEG, NEGX, NOT, TST *)
  VAR mode, reg, extWord, format : INTEGER;
    bd : LONGINT;
 BEGIN (* Format7 *)
  Encode( dest, mode, reg, extWord, format, bd, 0 );
  PutWord( 4000H + SYSTEM.LSH( opcode, 8 ) + SYSTEM.LSH( LengthCode( dest.typ.size ), 6 ) +
     SYSTEM.LSH( mode, 3 ) + reg );
  PutExtension( format, extWord, bd )
 END Format7;
 PROCEDURE Moveq*( val : INTEGER; reg : INTEGER );
 (* Writes the code for MOVEQ.L #val, Dreg *)
 BEGIN (* Moveq *)
  IF val < 0 THEN INC( val, 256 ) END;
  PutWord( 7000H + SYSTEM.LSH( reg, 9 ) + val )
 END Moveq;
 PROCEDURE Move*( VAR source, dest : Item );
 (* Writes the code for MOVE source, dest. Instruction size is source.typ.size. *)
 (* move #0,?? >> clr ?? *)
 (* move.l #b,d? (-127<=b<=127 >> Moveq *)
  VAR sourceMode, sourceReg, sourceExtWord, sourceFormat,
    destMode, destReg, destExtWord, destFormat,
    sizeCode : INTEGER;
    sourcebd, destbd : LONGINT;
 BEGIN (* Move *)
  IF (source.mode=imm) & (source.bd=0) & (dest.mode#pcx) & (dest.mode#areg) THEN		(*<<OJ*)
   Format7(2, dest); (* clr dest *)
  ELSIF (source.mode=imm) & (dest.mode=dreg) & (source.typ.size=4) & (dest.bd<128) & (dest.bd>-128) & (~(dest.mode=pcx)) THEN
   Moveq(SHORT(source.bd), dest.reg)
  ELSE
   CASE LengthCode( source.typ.size ) OF
    byte : sizeCode := 1
    | word : sizeCode := 3
    | long : sizeCode := 2
   END; (* CASE *)
   Encode( dest, destMode, destReg, destExtWord, destFormat, destbd, 0 );
   Encode( source, sourceMode, sourceReg, sourceExtWord, sourceFormat, sourcebd, 2 );
   PutWord( SYSTEM.LSH( sizeCode, 12 ) + SYSTEM.LSH( destReg, 9 ) + SYSTEM.LSH( destMode, 6 ) +
       SYSTEM.LSH( sourceMode, 3 ) + sourceReg );
   PutExtension( sourceFormat, sourceExtWord, sourcebd );
   PutExtension( destFormat, destExtWord, destbd )
  END
 END Move;
 PROCEDURE Movem*( dir, regList : INTEGER; VAR item : Item );
 (* Writes the code for MOVEM.L *)
  VAR mode, reg, extWord, format, OneReg : INTEGER;
    bd : LONGINT;
    source, dest: Item;
  PROCEDURE TestAnz(regs: INTEGER): INTEGER;		(*<<RD*)
  	VAR i, erg: INTEGER; 
  BEGIN
  	i:=0; erg:=-1;
  	LOOP
  		IF ODD(regs) THEN
  			IF erg#-1 THEN RETURN -1 END;
  			erg:=i
  		END;
  		regs:=regs DIV 2;
  		INC(i);
  		IF i=16 THEN RETURN erg END;
  	END;
  END TestAnz;
 BEGIN (* Movem *)
  OneReg:=TestAnz(regList);		(*<<RD*)
  IF OneReg#-1 THEN	(* only one Reg to move *)
   IF dir=0 THEN
    PutWord( 2F00H + 15 - OneReg)	(* MOVE.L Reg, -(A7) *)
   ELSE
    IF OneReg<8 THEN
     PutWord( 201FH + SYSTEM.LSH(OneReg, 9))	(* MOVE.L (A7)+, Dx *)
    ELSE
     PutWord( 205FH + SYSTEM.LSH(OneReg-8, 9))	(* MOVEA.L (A7)+, Ax *)
    END;
   END;
  ELSE									(* >1 Reg to move *)
   Encode( item, mode, reg, extWord, format, bd, 0 );
   PutWord( 48C0H + SYSTEM.LSH( dir, 10 ) + SYSTEM.LSH( mode, 3 ) + reg );
   PutWord( regList );
   PutExtension( format, extWord, bd )
  END
 END Movem;
 PROCEDURE FMove*( VAR source, dest : Item );
 (* Writes the code for FMOVE.size source, dest. Packed Decimal Real is not supported. *)
 (* move from FPReg to FPReg only knows .X and has its own command, real strange bug *)
  VAR mode, reg, extWord, format : INTEGER;
    bd : LONGINT;
 BEGIN (* FMove *)
  IF dest.mode = freg THEN
   IF source.mode = freg THEN
    PutWord( CP);
    PutWord(SYSTEM.LSH(source.reg-16, 10) + SYSTEM.LSH(dest.reg-16, 7))
   ELSE
    Encode( source, mode, reg, extWord, format, bd, 4 );
    PutWord( CP + SYSTEM.LSH( mode, 3 ) + reg );
    PutWord( 4000H + SYSTEM.LSH( FloatFormat( source.typ ), 10 ) + SYSTEM.LSH( dest.reg - 16, 7 ) );
    PutExtension( format, extWord,  bd )
   END
  ELSIF source.mode = freg THEN
   Encode( dest, mode, reg, extWord, format, bd, 0 );
   PutWord( CP + SYSTEM.LSH( mode, 3 ) + reg );
   PutWord( 6000H + SYSTEM.LSH( FloatFormat( source.typ ), 10 ) + SYSTEM.LSH( source.reg - 16, 7 ) );
   PutExtension( format, extWord, bd )
  ELSE
   HALT( 95 )
  END; (* IF *)
 END FMove;
 PROCEDURE FMovecr*( VAR item : Item; dr, controlReg : INTEGER );
 (* Writes the code for FMOVE von oder nach einem Control Register. *)
  VAR mode, reg, extWord, format : INTEGER;
    bd : LONGINT;
 BEGIN (* FMovecr *)
  Encode( item, mode, reg, extWord, format, bd, 4 );
  PutWord( CP + SYSTEM.LSH( mode, 3 ) + reg );
  PutWord( 8000H + SYSTEM.LSH( dr, 13 ) + SYSTEM.LSH( controlReg, 10 ) );
  PutExtension( format, extWord, bd )
 END FMovecr;
 PROCEDURE FMovem*( dir, regList : INTEGER; VAR item : Item );
 (* Writes the code for FMOVEM.X. For (SP)+ and -(SP) only! *)
  VAR mode, reg, extWord, format : INTEGER;
    bd : LONGINT;
 BEGIN (* FMovem *)
  Encode( item, mode, reg, extWord, format, bd, 0 );
  PutWord( CP + SYSTEM.LSH( mode, 3 ) + reg );
  PutWord( 0C000H + SYSTEM.LSH( 1 - dir, 13 ) + SYSTEM.LSH( dir, 12 ) + regList );
  (* without PutExtension! *)
 END FMovem;
 PROCEDURE Load*( VAR item : Item );
 (* Loads the item into a data register. *)
  VAR source : Item;
 BEGIN (* Load *)
  IF item.mode # dreg THEN
   source := item;
   item.mode := dreg;
   item.reg := GetReg( );
   IF source.mode = freg THEN
    FMove( source, item )
   ELSE
    Move( source, item )
   END; (* IF *)
  END; (* IF *)
 END Load;
 PROCEDURE FLoad*( VAR item : Item );
 (* Loads the item into a floating point register. *)
  VAR regItem : Item;
 BEGIN (* FLoad *)
  IF item.mode # freg THEN
   regItem.mode := freg;
   regItem.typ := item.typ;
   regItem.reg := GetFReg( );
   FMove( item, regItem );
   item := regItem
  END; (* IF *)
 END FLoad;
 PROCEDURE AssertDestReg*( typ : OPT.Struct; VAR source, dest : Item );
 (* Makes sure that dest is a register, either by swapping the items or by loading dest. *)
  VAR swap : Item;
 BEGIN (* AssertDestReg *)
  IF ( typ = OPT.realtyp ) OR ( typ = OPT.lrltyp ) THEN
   IF dest.mode # freg THEN
    IF source.mode = freg THEN
     swap := dest;
     dest := source;
     source := swap
    ELSE
     FLoad( dest )
    END; (* IF *)
   END; (* IF *)
  ELSE
   IF dest.mode # dreg THEN
    IF source.mode = dreg THEN
     swap := dest;
     dest := source;
     source := swap
    ELSE
     Load( dest )
    END; (* IF *)
   END; (* IF *)
  END; (* IF *)
 END AssertDestReg;
 PROCEDURE TFConds*( tcond : LONGINT ) : LONGINT;
 (* Converts a condition code to true- and false-conditions. *)
  VAR fcond : INTEGER;
 BEGIN (* TFConds *)
  CASE tcond OF
   CC : fcond := CS
   | CS : fcond := CC
   | EQ : fcond := NE
   | NE : fcond := EQ
   | false : fcond := true
   | true : fcond := false
   | GE : fcond := LT
   | LT : fcond := GE
   | GT : fcond := LE
   | LE : fcond := GT
   | HI : fcond := LS
   | LS : fcond := HI
   | MI : fcond := PL
   | PL : fcond := MI
   | VC : fcond := VS
   | VS : fcond := VC
  END; (* CASE *)
  RETURN 10000H * tcond + fcond
 END TFConds;
 PROCEDURE TFFConds*( tcond : LONGINT ) : LONGINT;
 (* Converts a floating point condition code to true- and false-conditions. *)
  VAR fcond : INTEGER;
 BEGIN (* TFFConds *)
  CASE tcond OF
   FEQ : fcond := FNE
   | FNE : fcond := FEQ
   | FGE : fcond := FNGE
   | FLT : fcond := FNLT
   | FGT : fcond := FNGT
   | FLE : fcond := FNLE
  END; (* CASE *)
  RETURN 10000H * tcond + fcond
 END TFFConds;
 PROCEDURE Chk*( VAR item, chkItem : Item );
 (* Writes the code for CHK. *)
 (* move ??,dx chk dx,dy changed to chk ??,dy *)
  VAR mode, reg, extWord, format, size : INTEGER;
    bd : LONGINT;
 BEGIN (* Chk *)
  IF item.typ = OPT.linttyp THEN
   size := 0
  ELSE
   size := 1
  END;
  Load( item );
  (* Load( chkItem ); *)
  Encode( chkItem, mode, reg, extWord, format, bd, 2 );
  PutWord( 4100H + SYSTEM.LSH( item.reg, 9 ) + SYSTEM.LSH( size, 7 ) + SYSTEM.LSH( mode, 3 ) + reg );
  PutExtension( format, extWord, bd )
 END Chk;
 PROCEDURE DBcc*( condition : INTEGER; VAR reg : INTEGER; VAR label : Label );
 (* Writes the code for DBcc. label must be defined. *)
 BEGIN (* DBcc *)
  PutWord( 50C8H + SYSTEM.LSH( condition, 8 ) + reg );
  PutWord( label - pc )
 END DBcc;
 PROCEDURE Ext*( VAR reg : Item; destSize : INTEGER );
 (* Writes the code for EXT and EXTB. destSize is the desired length code.*)
 BEGIN (* Ext *)
  Load( reg );
  IF reg.typ.size = 1 THEN
   IF destSize = word THEN
    PutWord( 4880H + reg.reg )
   ELSE (* long *)
    PutWord( 49C0H + reg.reg )
   END
  ELSIF reg.typ.size = 2 THEN
   PutWord( 48C0H + reg.reg )
  END; (* IF *)
 END Ext;
 PROCEDURE Divsl*( VAR source, remainder, quotient : Item );
 (* Writes the code for DIVSL.L source, remainder:quotient. *)
  VAR mode, reg, extWord, format : INTEGER;
    bd : LONGINT;
 BEGIN (* Divsl *)
  Load( remainder );
  Load( quotient );
  Encode( source, mode, reg, extWord, format, bd, 4 );
  PutWord( 4C40H + SYSTEM.LSH( mode, 3 ) + reg );
  PutWord( 800H + SYSTEM.LSH( quotient.reg, 12 ) + remainder.reg );
  PutExtension( format, extWord, bd )
 END Divsl;
 PROCEDURE Swap*( VAR dest : Item );
 (* Writes the code for SWAP. *)
 BEGIN (* Swap *)
  Load( dest );
  PutWord( 4840H + dest.reg )
 END Swap;
 PROCEDURE Eor*( VAR source, dest : Item );
 (* Writes the code for EOR source, dest. *)
  VAR mode, reg, extWord, format : INTEGER;
    bd : LONGINT;
 BEGIN (* Eor *)
  Load( source );
  Encode( dest, mode, reg, extWord, format, bd, 0 );
  PutWord( 0B100H + SYSTEM.LSH( source.reg, 9 ) + SYSTEM.LSH( LengthCode( dest.typ.size ), 6 ) +
      SYSTEM.LSH( mode, 3 ) + reg );
  PutExtension( format, extWord, bd )
 END Eor;
 PROCEDURE Enter*( val : LONGINT );
 (* Writes the code for procedure or module entry. *)
 BEGIN
  IF DispSize( val ) = 3 THEN
   PutWord( 480EH );
   PutLongWord( val )
  ELSE
   PutWord( 4E56H );
   PutWord( val )
  END; (* IF *)
 END Enter;
 PROCEDURE Return*;
 (* Writes the code for procedure or module exit. *)
 BEGIN
  PutWord( 4E5EH ); (* UNLK A6 *)
  PutWord( 4E75H ); (* RTS *)
 END Return;
 PROCEDURE WriteCProc*( code : OPT.ConstExt );
 (* Writes the code of a code procedure. *)
  VAR i, n : INTEGER;
 BEGIN (* WriteCProc *)
  n := ORD( code^[ 0 ] );
  FOR i := 1 TO n DO PutByte( ORD( code^[ i ] ) ) END
 END WriteCProc;
 PROCEDURE Format1*( opcode : LONGINT; data : INTEGER; VAR dest : Item );
 (* ADDQ, SUBQ *)
  VAR mode, reg, extWord, format : INTEGER;
    bd : LONGINT;
 BEGIN (* Format1 *)
  Encode( dest, mode, reg, extWord, format, bd, 0 );
  IF data = 8 THEN data := 0 END;
  PutWord( 5000H + SYSTEM.LSH( data, 9 ) + SYSTEM.LSH( opcode, 8 ) + SYSTEM.LSH( LengthCode( dest.typ.size ), 6 ) +
      SYSTEM.LSH( mode, 3 ) + reg );
  PutExtension( format, extWord, bd )
 END Format1;
 PROCEDURE Format6*( opcode : LONGINT; data : LONGINT; VAR dest : Item );
 (* ADDI, ANDI, CMPI, EORI, ORI, SUBI *)
  VAR size, mode, reg, extWord, format : INTEGER;
    bd : LONGINT;
 BEGIN (* Format6 *)
  size := LengthCode( dest.typ.size );
  Encode( dest, mode, reg, extWord, format, bd, 0 );
  PutWord( SYSTEM.LSH( opcode, 8 ) + SYSTEM.LSH( size, 6 ) + SYSTEM.LSH( mode, 3 ) + reg );
  IF size = long THEN
   PutLongWord( data )
  ELSE
   PutWord( data )
  END; (* IF *)
  PutExtension( format, extWord, bd )
 END Format6;
 PROCEDURE Format2*( opcode : LONGINT; VAR source, dest : Item );
 (* ADD, AND, OR, SUB *)
  VAR mode, reg, extWord, format, size : INTEGER;
    bd : LONGINT;
 BEGIN (* Format2 *)
  size := LengthCode( source.typ.size );
  IF dest.mode = dreg THEN
   Encode( source, mode, reg, extWord, format, bd, 2 );
   PutWord( SYSTEM.LSH( opcode, 12 ) + SYSTEM.LSH( dest.reg, 9 ) + SYSTEM.LSH( size, 6 ) + SYSTEM.LSH( mode, 3 ) + reg );
   PutExtension( format, extWord, bd )
  ELSE
   Load( source );
   Encode( dest, mode, reg, extWord, format, bd, 0 );
   PutWord( 100H + SYSTEM.LSH( opcode, 12 ) + SYSTEM.LSH( source.reg, 9 ) + SYSTEM.LSH( size, 6 ) +
       SYSTEM.LSH( mode, 3 ) + reg );
   PutExtension( format, extWord, bd )
  END; (* IF *)
 END Format2;
 PROCEDURE Format3*( opcode : LONGINT; VAR source : Item; destReg : INTEGER );
 (* ADDA, SUBA *)
 (* uses ADDQ/SUBQ if possible *)
 (* try to collect ADDA #x,A7 and SUBA #y,A7 *)
  VAR mode, reg, extWord, format, size : INTEGER;
    bd : LONGINT;
    dest: Item;
    ImmFlag: BOOLEAN;
 BEGIN (* Format3 *)
  ImmFlag:=FALSE;
  IF (source.mode=imm) & (destReg=8+7) THEN
   ImmFlag:=TRUE;
   IF (LastSubEnd=pc) THEN
    pc:=LastSubBegin;
    IF opcode=13 THEN
     INC(SubWert, source.bd)
    ELSE
     DEC(SubWert, source.bd)
    END;
    IF SubWert>0 THEN
     source.bd:=SubWert;opcode:=13
    ELSE
     source.bd:=-SubWert;opcode:=9
    END
   ELSE
    IF opcode=13 THEN
     SubWert:=source.bd
    ELSE
     SubWert:=-source.bd
    END
   END;
   LastSubBegin:=pc
  END;
  IF (source.mode=imm) & (~(dest.mode=pcx)) & (source.bd>0) & (source.bd<=16) THEN
   dest.mode:=areg;dest.reg:=destReg;dest.inxReg:=-1;NEW(dest.typ);dest.typ.size:=source.typ.size;
   IF (opcode=13) THEN opcode:=0 ELSE opcode:=1 END;
   IF source.bd>8 THEN
    Format1(opcode, 8, dest);
    DEC(source.bd, 8)
   END;
   Format1(opcode, SHORT(source.bd), dest)
  ELSIF ~((source.mode=imm) & (source.bd=0)) THEN
   IF LengthCode( source.typ.size ) = long THEN
    size := 1
   ELSE
    size := 0
   END; (* IF *)
   Encode( source, mode, reg, extWord, format, bd, 2 );
   PutWord( 0C0H + SYSTEM.LSH( opcode, 12 ) + SYSTEM.LSH( destReg - 8, 9 )+ SYSTEM.LSH( size, 8 ) +
       SYSTEM.LSH( mode, 3 ) + reg );
   PutExtension( format, extWord, bd )
  END;
  IF ImmFlag THEN
   LastSubEnd:=pc
  END
 END Format3;
 PROCEDURE Format4*( opcode : LONGINT; bitnr : LONGINT; VAR dest : Item );
 (* BSET, BCLR, BCHG, BTST, static bit number. *)
  VAR mode, reg, extWord, format : INTEGER;
    bd : LONGINT;
 BEGIN (* Format4 *)
  Load( dest );
  Encode( dest, mode, reg, extWord, format, bd, 0 );
  PutWord( 0800H + SYSTEM.LSH( opcode, 6 ) + SYSTEM.LSH( mode, 3 ) + reg );
  PutWord( bitnr );
  PutExtension( format, extWord, bd )
 END Format4;
 PROCEDURE Format5*( opcode : LONGINT; VAR bitnr, dest : Item );
 (* BSET, BCLR, BCHG, BTST, dynamic bit number. *)
  VAR mode, reg, extWord, format : INTEGER;
    bd : LONGINT;
 BEGIN (* Format5 *)
  Load( bitnr );
  Load( dest );
  Encode( dest, mode, reg, extWord, format, bd, 0 );
  PutWord( 0100H + SYSTEM.LSH( bitnr.reg, 9 ) + SYSTEM.LSH( opcode, 6 ) + SYSTEM.LSH( mode, 3 ) + reg );
  PutExtension( format, extWord, bd )
 END Format5;
 PROCEDURE Format8*( opcode : LONGINT; VAR source, dest : Item );
 (* Coprocessor operation. *)
  VAR mode, reg, extWord, format : INTEGER;
    bd : LONGINT;
 BEGIN (* Format8 *)
  FLoad( dest );
  IF source.mode = freg THEN
   PutWord( CP );
   PutWord( SYSTEM.LSH( source.reg - 16, 10 ) + SYSTEM.LSH( dest.reg - 16, 7 ) + opcode )
  ELSE
   Encode( source, mode, reg, extWord, format, bd, 4 );
   PutWord( CP + SYSTEM.LSH( mode, 3 ) + reg );
   PutWord( 4000H + SYSTEM.LSH( FloatFormat( source.typ ), 10 ) + SYSTEM.LSH( dest.reg - 16, 7 ) + opcode );
   PutExtension( format, extWord, bd )
  END; (* IF *)
 END Format8;
(* I think, Format9 and Format 10 are never used => no bitfields *)
 PROCEDURE Format9*( opcode : LONGINT; VAR dest : Item; offset, width : INTEGER );
 (* BFCHG, BFCLR, BFSET, BFTST, static offset and width. *)
  VAR mode, reg, extWord, format : INTEGER;
    bd : LONGINT;
 BEGIN (* Format9 *)
  Load( dest );
  IF width > 0 THEN
   IF width = 32 THEN width := 0 END;
   Encode( dest, mode, reg, extWord, format, bd, 0 );
   PutWord( 0E0C0H + SYSTEM.LSH( opcode, 8 ) + SYSTEM.LSH( mode, 3 ) + reg );
   PutWord( SYSTEM.LSH( offset, 6 ) + width );
   PutExtension( format, extWord, bd )
  END; (* IF *)
 END Format9;
 PROCEDURE Format10*( opcode : LONGINT; offset : INTEGER; VAR width, dest : Item );
 (* BFCHG, BFCLR, BFSET, BFTST, static offset, dynamic width. *)
  VAR mode, reg, extWord, format : INTEGER;
    bd : LONGINT;
 BEGIN (* Format10 *)
  Load( width );
  Load( dest );
  Encode( dest, mode, reg, extWord, format, bd, 0 );
  PutWord( 0E0C0H + SYSTEM.LSH( opcode, 8 ) + SYSTEM.LSH( mode, 3 ) + reg );
  PutWord( 20H + SYSTEM.LSH( offset, 6 ) + width.reg );
  PutExtension( format, extWord, bd )
 END Format10;
 PROCEDURE Format11*( opcode : LONGINT; VAR source, dest : Item );
 (* MULU, MULS, DIVU, DIVS (short form) *)
  VAR mode, reg, extWord, format : INTEGER;
    bd : LONGINT;
 BEGIN (* Format11 *)
  Load( dest );
  Encode( source, mode, reg, extWord, format, bd, 2 );
  PutWord( opcode + SYSTEM.LSH( dest.reg, 9 ) + SYSTEM.LSH( mode, 3 ) + reg );
  PutExtension( format, extWord, bd )
 END Format11;
 PROCEDURE Format12*( opcode : LONGINT; VAR source, dest : Item );
 (* MULU, MULS, DIVU, DIVS (long form with one result register) *)
  VAR mode, reg, extWord, format, bit6, bit11 : INTEGER;
    bd : LONGINT;
 BEGIN (* Format12 *)
  IF opcode = MULU THEN bit6 := 0; bit11 := 0
  ELSIF opcode = MULS THEN bit6 := 0; bit11 := 1
  ELSIF opcode = DIVU THEN bit6 := 1; bit11 := 0
  ELSIF opcode = DIVS THEN bit6 := 1; bit11 := 1
  END; (* IF *)
  Load( dest );
  Encode( source, mode, reg, extWord, format, bd, 4 );
  PutWord( 4C00H + SYSTEM.LSH( bit6, 6 ) + SYSTEM.LSH( mode, 3 ) + reg );
  PutWord( SYSTEM.LSH( dest.reg, 12 ) + SYSTEM.LSH( bit11, 11 ) + dest.reg );
  PutExtension( format, extWord, bd )
 END Format12;
 PROCEDURE Format13*( opcode, shiftleft : INTEGER; VAR dest : Item );
 (* ASL, ASR, LSL, LSR, ROL, ROR, ROXL, ROXR, static number of bits. *)
  VAR dr, size : INTEGER;
 BEGIN (* Format13 *)
  size := LengthCode( dest.typ.size );
  IF shiftleft > 0 THEN dr := 1 ELSE dr := 0 END;
  IF ABS( shiftleft ) = 8 THEN shiftleft := 0 END;
  Load( dest );
  PutWord( 0E000H + SYSTEM.LSH( ABS( shiftleft ), 9 ) + SYSTEM.LSH( dr, 8 ) + SYSTEM.LSH( size, 6 )
       + SYSTEM.LSH( opcode, 3 ) + dest.reg )
 END Format13;
 PROCEDURE Format14*( opcode, dr : INTEGER; VAR shift, dest : Item );
 (* ASL, ASR, LSL, LSR, ROL, ROR, ROXL, ROXR, dynamic number of bits. *)
 BEGIN (* Format14 *)
  Load( shift );
  Load( dest );
  PutWord( 0E020H + SYSTEM.LSH( shift.reg, 9 ) + SYSTEM.LSH( dr, 8 ) + SYSTEM.LSH( LengthCode( dest.typ.size ), 6 )
      + SYSTEM.LSH( opcode, 3 ) + dest.reg )
 END Format14;
 PROCEDURE Format15*( opcode : INTEGER; VAR item : Item );
 (* JMP, JSR, PEA *)
  VAR mode, reg, extWord, format : INTEGER;
    bd : LONGINT;
 BEGIN (* Format15 *)
  Encode( item, mode, reg, extWord, format, bd, 2 );
  PutWord( 4000H + SYSTEM.LSH( opcode, 6 ) + SYSTEM.LSH( mode, 3 ) + reg );
  PutExtension( format, extWord, bd )
 END Format15;
 PROCEDURE Cmp*( VAR source, dest : Item );
 (* Writes the code for CMP source, dest. *)
 (* cmp #a,?? >> cmpi #a,?? or tst ?? if a=0 *)
  VAR mode, reg, extWord, format, size : INTEGER;
    bd : LONGINT;
 BEGIN (* Cmp *)
  size:= LengthCode( source.typ.size );
  IF (source.mode=imm) & (source.bd=0) & (~(dest.mode=pcx)) THEN (* TST *)
         (*Encode( dest, mode, reg, extWord, format, bd, 2 );
         PutWord( 4A00H + SYSTEM.LSH( size, 6 ) + SYSTEM.LSH( mode, 3 ) + reg );*)
   Format7(10, dest)
  ELSIF (source.mode=imm) & (~(dest.mode=pcx)) THEN (* CMPI *)
         (*Encode( dest, mode, reg, extWord, format, bd, 6 );
         PutWord(  0C00H + SYSTEM.LSH( size, 6 ) + SYSTEM.LSH( mode, 3 ) + reg );
         IF size = long THEN
          PutLongWord( source.bd )
         ELSIF size = word THEN
          PutWord( source.bd )
         ELSE
          PutByte( 0);PutByte( source.bd)
         END; (* IF *)*)
   Format6(12, source.bd, dest)
  ELSE
   Load(dest);
   Encode( source, mode, reg, extWord, format, bd, 2 );
   PutWord( 0B000H + SYSTEM.LSH( dest.reg, 9 ) + SYSTEM.LSH( size, 6 ) +
       SYSTEM.LSH( mode, 3 ) + reg );
   PutExtension( format, extWord, bd )
  END
 END Cmp;
 PROCEDURE OutRefPoint*;
 BEGIN (* OutRefPoint *)
  OPM.RefW( 0F8X );
  OPM.RefWInt( pc )
 END OutRefPoint;
 PROCEDURE OutRefName*( name : ARRAY OF CHAR );
 (* Writes a name to the reference file. *)
  VAR ch : CHAR;
    i : INTEGER;
 BEGIN (* OutRefName *)
  i := 0;
  REPEAT
   ch := name[ i ];
   OPM.RefW( ch );
   INC( i )
  UNTIL ch = 0X
 END OutRefName;
 PROCEDURE OutRefs*( obj : OPT.Object );
 (* Writes the reference information of the variables. *)
  VAR f : INTEGER;
 BEGIN (* OutRefs *)
  IF obj # NIL THEN
   OutRefs( obj^.left );
   IF ( obj^.mode = Var ) OR ( obj^.mode = VarPar ) THEN
    f := obj^.typ^.form;
    IF ( f IN { Byte .. Set, Pointer } ) OR ( obj^.typ^.comp = Array ) & ( obj^.typ^.BaseTyp^.form = Char ) THEN
     IF obj^.mode = Var THEN OPM.RefW( 1X ) ELSE OPM.RefW( 3X ) END;
     IF obj^.typ^.comp = Array THEN OPM.RefW( 0FX )
     ELSE OPM.RefW( CHR( f ) )
     END;
     OPM.RefWInt( obj^.linkadr );
     OutRefName( obj^.name )
    END
   END;
   OutRefs(obj^.right)
  END
 END OutRefs;
 PROCEDURE WriteName( VAR name : ARRAY OF CHAR; n : INTEGER );
 (* Writes name to the object file with at least n characters. *)
  VAR i : INTEGER; ch : CHAR;
 BEGIN
  i := 0;
  REPEAT
   ch := name[ i ];
   OPM.ObjW( ch );
   INC( i )
  UNTIL ch = 0X;
  WHILE i < n DO OPM.ObjW( 0X ); INC( i ) END
 END WriteName;
 PROCEDURE OutCode*( VAR modName : ARRAY OF CHAR; key : LONGINT );
 (* Writes the object file. *)
  VAR i : LONGINT;
    nofcom, nofptrs : INTEGER;
    obj : OPT.Object;
    comTab : ARRAY MaxComs OF OPT.Object;
    ptrTab : ARRAY MaxPtrs OF LONGINT;
  PROCEDURE Traverse( obj : OPT.Object );
  (* Collects commands in comTab and global pointers in ptrTab. Increments nofcom and nofptrs accordingly. *)
  BEGIN (* Traverse *)
   IF obj # NIL THEN
    IF obj.mode = XProc THEN
     IF ( obj.vis # internal ) & ( obj.link = NIL ) & ( obj.typ = OPT.notyp ) THEN (* command *)
      IF nofcom < MaxComs THEN
       comTab[ nofcom ] := obj;
       INC(nofcom)
      ELSE
       OPM.Mark(232, 0);
       nofcom := 0
      END; (* IF *)
     END; (* IF *)
    ELSIF ( obj.mode = Var ) & ( obj.linkadr < 0 ) THEN
     FindPtrs( obj.typ, obj.linkadr, ptrTab, nofptrs )
    END; (* IF *)
    Traverse( obj.left );
    Traverse( obj.right )
   END; (* IF *)
  END Traverse;
 BEGIN (* OutCode *)
  nofcom := 0;
  nofptrs := 0;
  Traverse( OPT.topScope.right );
 (* header block *)
  OPM.ObjWInt( entno );
  OPM.ObjWInt( nofcom );
  OPM.ObjWInt( nofptrs );
  OPM.ObjWInt( OPT.nofGmod );
  OPM.ObjWInt( link );
  OPM.ObjWLInt( dsize );
  OPM.ObjWLInt( ConstSize - conx );
  OPM.ObjWLInt( pc );
  OPM.ObjWLInt( key );
  WriteName( modName, 24 );
 (* entry block *)
  OPM.ObjW( 82X );
  FOR i := 0 TO entno - 1 DO OPM.ObjWLInt( entry[ i ] ) END;
 (* command block *)
  OPM.ObjW( 83X );
  FOR i := 0 TO nofcom - 1 DO
   obj := comTab[ i ];
   WriteName( obj.name, 0 );
   OPM.ObjWLInt( entry[ obj.adr ] )
  END; (* FOR *)
 (* pointer block *)
  OPM.ObjW( 84X );
  FOR i := 0 TO nofptrs - 1 DO OPM.ObjWLInt( ptrTab[ i ] ) END;
 (* import block *)
  OPM.ObjW( 85X );
  FOR i := 0 TO OPT.nofGmod - 1 DO
   obj := OPT.GlbMod[ i ];
   OPM.ObjWLInt( obj.adr );
   WriteName( obj.name, 0 )
  END; (* FOR *)
 (* data block *)
  OPM.ObjW( 86X );
  FOR i := conx TO ConstSize - 1 DO OPM.ObjW( SYSTEM.VAL( CHAR, constant[ i ] ) ) END;
 (* code block *)
  OPM.ObjW( 87X );
  OPM.ObjWBytes( code, pc );
 (* ref block written in OPM.CloseRefObj *)
 END OutCode;
 PROCEDURE Close*;
 END Close;
END OPL.